home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swags_z.zip / SCROLL.SWG / 0007_Scrolling Demo.pas < prev    next >
Pascal/Delphi Source File  |  1993-11-02  |  9KB  |  312 lines
  1. {
  2. S921878@MINYOS.XX.RMIT.OZ.AU, Daniel John Lee Parnell
  3.  
  4.  I have received several requests for the source code to the
  5. scrolly demo I posted to this group.  Sorry about posting a binary.  I
  6. didn't know it was not allowed on this group.  Anyway the following is the
  7. source code to the scrolly.  It is not a unit.  It uses one 286
  8. instruction so it wont work on an XT :(
  9. }
  10.  
  11. {$G+}
  12. program ColorBars;
  13.  
  14. uses
  15.   DOS, CRT;
  16.  
  17. const
  18.   maxBars  = 7;
  19.   maxStars = 100;
  20.   maxLines = 7;
  21.   m : array [1..maxLines] of string =
  22.      ('Welcome to my first scrolly demo on the PC.    It was written using ',
  23.       'Turbo Pascal 6.0 on the 7th of October 1993.  This program took me ',
  24.       'about 2 hours to write and I had a lot of fun writing it!         ',
  25.       'I suppose I''d better put in some greets I guess...............',
  26.       'Greetings go to      Robyn       Adam       Rowan      Mandy       ',
  27.       '   Weng       Speed      Shane      Iceberg Inc.       And anybody ',
  28.       'else out there whom I have forgotten about......         ');
  29.  
  30. var
  31.   colors   : array [0..768] of byte;
  32.   rMsk,
  33.   gMsk,
  34.   bMsk     : array [0..255] of byte;
  35.   y, dy, s : array [1..maxBars]  of integer;
  36.   sx, sy,
  37.   sdx      : array [1..maxStars] of integer;
  38.   tx, ty   : array [0..640]      of integer;
  39.   dot      : integer;
  40.   ticks    : word;
  41.   scrly    : array [0..360] of integer;
  42.   mpos,
  43.   mlen     : integer;
  44.  
  45. procedure SetMode(m : integer);   { Set video mode }
  46. var
  47.   regs : registers;
  48. begin
  49.   regs.ax := m;
  50.   intr($10, regs);
  51. end;
  52.  
  53. procedure WaitRetrace;          { Wait for vertical retrace }
  54. begin
  55.   repeat { Nothing } until (Port[$03da] and 8) <> 0;
  56. end;
  57.  
  58. procedure WaitNotRetrace;       { Wait for not vertical retrace }
  59. begin
  60.   repeat { Nothing } until (Port[$03da] and 8) <> 8;
  61. end;
  62.  
  63. procedure InitScreen;           { Sets up the colored bars }
  64. var
  65.   i, j : integer;
  66. begin
  67.   for i := 0 to 199 do
  68.     for j := 0 to 319 do
  69.       mem[$a000 : i * 320 + j] := i;
  70. end;
  71.  
  72. procedure InitColors;           { Zeros the first 200 colors }
  73. var
  74.   i : integer;
  75. begin
  76.   for i := 0 to 199 * 3 do
  77.     colors[i] := 0;
  78. end;
  79.  
  80. procedure SetColors; assembler;   { Loads the colors into the regs }
  81. asm
  82.  @ntrace:                { Wait for not retrace }
  83.   mov  dx, $03da
  84.   in   al, dx
  85.   test al, 8
  86.   jnz  @vtrace
  87.  
  88.  @vtrace:                { Now wait for retrace }
  89.   mov  dx, $03da
  90.   in   al, dx
  91.   test al, 8
  92.   jz   @vtrace
  93.  
  94.   mov  dx, $03c8          { Start changeing colors from color # 1 }
  95.   mov  al, 1
  96.   out  dx, al
  97.  
  98.   inc  dx                { Make DX point to the color register }
  99.   mov  cx, 199*3          { The number of bytes to put into the color register }
  100.   mov  si, offset colors  { Load the address of the color array }
  101.   rep  outsb             { Now change the colors }
  102. end;
  103.  
  104. procedure CalcBars;     { Calculate the color bars }
  105. var
  106.   i, j, k : integer;
  107. begin
  108.   for i := 0 to 199 * 3 do  { Zero all the colors }
  109.     colors[i] := 0;
  110.  
  111.   for i := 1 to maxBars do { Now process each bar in turn }
  112.   begin
  113.     y[i] := y[i] + dy[i];  { Move the bar }
  114.     if (y[i] < 4) or (y[i] > 190) then  { Has it hit the top or the bottom? }
  115.     begin
  116.       dy[i] := -dy[i];              { Yes, so make it bounce }
  117.       y[i]  := y[i] + dy[i];
  118.     end;
  119.  
  120.   for j := (y[i] - s[i]) to (y[i] + s[i]) do  { Now update the color array }
  121.   begin
  122.     if j < y[i] then       { Calculate the intensity }
  123.       k := 63 - (y[i] - j) * 4
  124.     else
  125.       k := 63 - (j - y[i]) * 4;
  126.  
  127.     if j > 0 then          { If it is a valid color change it }
  128.     begin
  129.       colors[j * 3]     := (colors[j * 3]   + (k and rMsk[i]));   { Do red }
  130.       colors[j * 3 + 1] := (colors[j * 3 + 1] + (k and gMsk[i])); { Do green }
  131.       colors[j * 3 + 2] := (colors[j * 3 + 2] + (k and bMsk[i])); { Do blue }
  132.     end;
  133.     end;
  134.   end;
  135. end;
  136.  
  137. procedure InitBars;     { Set up the bars randomly }
  138. var
  139.   i : integer;
  140. begin
  141.   for i := 1 to MaxBars do
  142.   begin
  143.     y[i] := random(150)+4;       { Starting pos }
  144.     s[i] := random(6)+4;         { Size }
  145.  
  146.     rMsk[i] := random(2)*255;    { Red mask }
  147.     gMsk[i] := random(2)*255;    { Green mask }
  148.     bMsk[i] := random(2)*255;    { Blue mask }
  149.  
  150.     repeat                     { Calc direction }
  151.       dy[i] := random(6) - 3;
  152.     until dy[i] <> 0;
  153.   end;
  154. end;
  155.  
  156. procedure InitStars;            { Set up the stars }
  157. var
  158.   i : integer;
  159. begin
  160.   port[$03c8] := $f8;                     { Change the colors for stars }
  161.   for i := 7 downto 0 do
  162.   begin
  163.     port[$03c9] := 63 - (i shl 2);
  164.     port[$03c9] := 63 - (i shl 2);
  165.     port[$03c9] := 63 - (i shl 2);
  166.   end;
  167.  
  168.   for i := 1 to maxStars do
  169.   begin
  170.     sx[i]  := random(320);               { Choose  X pos }
  171.     sy[i]  := random(200);               {         Y pos }
  172.     sdx[i] := 1 shl random(3);          {         Speed }
  173.   end;
  174. end;
  175.  
  176. procedure InitScroll;   { Initialize the scrolly }
  177. const
  178.   k = 3.141 / 180;
  179. var
  180.   i : integer;
  181. begin
  182.   mlen := 0;                      { Calc length of scroll text }
  183.   for i := 1 to maxLines do
  184.    mlen := mlen + length(m[i]);
  185.  
  186.   for i := 0 to 640 do            { Zero all the star positions }
  187.     tx[i] := -1;
  188.  
  189.   for i := 0 to 360 do            { Calculate the scroll path }
  190.     scrly[i] := round(100 + 50 * sin(i * k));
  191. end;
  192.  
  193. procedure UpdateStars;          { Draw the stars }
  194. var
  195.   i, ad : integer;
  196. begin
  197.   for i := 1 to maxStars do
  198.   begin
  199.     ad := sx[i] + sy[i] * 320;              { Calc star address in video ram }
  200.     mem[$a000 : ad] := sy[i];             { Unplot old star pos }
  201.     sx[i] := sx[i] + sdx[i];              { Calc new star pos }
  202.  
  203.     if sx[i] > 319 then                 { Is it past the end of the screen? }
  204.     begin
  205.       sy[i] := random(200);           { Yes, generate a new star }
  206.       sx[i] := 0;
  207.       sdx[i] := 1 shl random(3);
  208.       ad := sx[i] + sy[i] * 320;
  209.     end;
  210.     mem[$a000:ad + sdx[i]] := $f7 + (sdx[i]) * 2;
  211.   end;
  212. end;
  213.  
  214. function msg(var i : integer) : char;     { Get a char from the scroll text }
  215. var
  216.   j, t, p : integer;
  217. begin
  218.   if i > mlen then                { Is I longer then the text? }
  219.     i := 1;
  220.  
  221.   j := 0;                         { Find which line it is in }
  222.   t := 0;
  223.   repeat
  224.     inc(j);
  225.     t := t + length(m[j]);
  226.   until i<t;
  227.  
  228.   p := i - t + length(m[j]);          { Calculate position in line }
  229.  
  230.   if p > 0 then
  231.     msg := m[j][p]
  232.   else
  233.     msg := chr(0);
  234.   inc(i);                       { Increment text position }
  235. end;
  236.  
  237. procedure NextChar;             { Create nex character in scroll text }
  238. var
  239.   ad   : word;
  240.   i, j,
  241.   q, c : integer;
  242. begin
  243.   c := ord(msg(mpos));            { Get the char }
  244.  
  245.   ad := $fa6e + (c * 8);              { Calc address of character image in ROM }
  246.   for i := 0 to 7 do
  247.   begin
  248.     q := mem[$f000 : ad + i];       { Get a byte of the image }
  249.     for j := 0 to 7 do
  250.     begin
  251.       if odd(q) then        { Is bit 0 set? }
  252.       begin
  253.         tx[dot] := 320 + (7 - j) * 4;   { If so add a dot to the list }
  254.         ty[dot] := i * 4;
  255.         inc(dot);
  256.         if dot > 640 then
  257.           dot := 0;
  258.       end;
  259.       q := q shr 1;           { Shift the byte one pos to the right }
  260.     end;
  261.   end;
  262. end;
  263.  
  264. procedure DisplayScroll;        { Display scrolly and update dot positions }
  265. var
  266.   i  : integer;
  267.   ad : word;
  268. begin
  269.   if (ticks mod 32) = 0 then      { Is it time for the next char? }
  270.     NextChar;
  271.  
  272.   for i := 0 to 640 do
  273.     if tx[i] > 0 then             { Is this dot being used? }
  274.     begin
  275.       if tx[i] < 320 then         { Is it on the screen? }
  276.       begin
  277.         ad := tx[i] + (ty[i] + scrly[tx[i]]) * 320;  { Calc old position }
  278.         mem[$a000:ad] := ty[i] + scrly[tx[i]];   { Clear old dot }
  279.       end;
  280.  
  281.       dec(tx[i]);                              { Move dot to the left }
  282.       ad := tx[i] + (ty[i] + scrly[tx[i]]) * 320;      { Calc new position }
  283.  
  284.       if (tx[i] > 0) and (tx[i] < 320) then        { Is it on the screen? }
  285.         mem[$a000:ad] := $ff - (ty[i] shr 2);      { Plot new dot }
  286.  
  287.     end;
  288. end;
  289.  
  290. begin
  291.   randseed := 4845267;            { Set up the random seed   }
  292.   SetMode($13);                 { Go to 320*200*256 mode   }
  293.   InitColors;                   { Blank the color array    }
  294.   SetColors;                    { Set the colors to black  }
  295.   InitScreen;                   { Set up the colored bars  }
  296.   InitBars;                     { Set up the bar positions }
  297.   InitStars;                    { Set up the stars         }
  298.   InitScroll;                   { Set up the scrolly       }
  299.   dot  := 0;                       { Set the dot counter to 0 }
  300.   mpos := 1;                      { Set up the text pos      }
  301.  
  302.   repeat
  303.     CalcBars;                   { Calculate the color bars   }
  304.     DisplayScroll;              { Display the scrolly text   }
  305.     UpdateStars;                { Update & display the stars }
  306.     SetColors;                  { Set the colors             }
  307.     inc(ticks);                 { Update the tick counter    }
  308.   until KeyPressed;
  309.  
  310.   SetMode(3);                   { Return to text mode }
  311. end.
  312.